home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / XLISP / XLISP21S / sources / c / dlimage < prev    next >
Text File  |  1992-04-25  |  15KB  |  544 lines
  1. /* xlimage - xlisp memory image save/restore functions */
  2. /*      Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use       */
  5. /* modified so that offset is in sizeof(node) units TAA */
  6. #include "xlisp.h"
  7.  
  8. #ifdef SAVERESTORE
  9.  
  10. #define FILENIL  ((OFFTYPE)0)   /* value of NIL in a file */
  11.  
  12. /* external variables */
  13. extern LVAL obarray,xlenv,xlfenv,xldenv,s_gchook,s_gcflag;
  14. extern long nnodes,nfree,total;
  15. extern int anodes,nsegs,gccalls;
  16. extern struct segment FAR *segs, FAR *lastseg, FAR *fixseg, FAR *charseg;
  17. extern CONTEXT *xlcontext;
  18. extern LVAL fnodes;
  19. extern int ftabsize;    /* TAA MOD -- added validity check */
  20.  
  21. /* external functions */
  22. #ifdef ANSI
  23. extern int scanvmemory(int size);
  24. extern void newvsegment(unsigned int n); /* really returns structure we
  25.                                             don't care about */
  26. #endif
  27.  
  28. /* For vector memory management */
  29. #define btow_size(n)    (((n) + sizeof(LVAL) - 1) / sizeof(LVAL))
  30.  
  31. typedef struct vsegment {
  32.     struct vsegment FAR *vs_next;   /* next vector segment */
  33.     LVAL FAR *vs_free;              /* next free location in this segment */
  34.     LVAL FAR *vs_top;               /* top of segment (plus one) */
  35.     LVAL vs_data[1];            /* segment data */
  36. } VSEGMENT;
  37.  
  38. extern VSEGMENT FAR *vsegments;     /* list of vector segments */
  39. extern VSEGMENT FAR *vscurrent;     /* current vector segment */
  40. extern int vscount;             /* number of vector segments */
  41. extern LVAL FAR *vfree;             /* next free location in vector space */
  42. extern LVAL FAR *vtop;              /* top of vector space */
  43.  
  44. /* local variables */
  45. static OFFTYPE off,foff;
  46. static FILEP fp;
  47.  
  48. /* forward declarations */
  49. #ifdef ANSI
  50. OFFTYPE NEAR readptr(void);
  51. OFFTYPE NEAR cvoptr(LVAL p);
  52. LVAL NEAR cviptr(OFFTYPE o);
  53. #ifdef SERVER
  54. void freeimage(void);
  55. #else
  56. void NEAR freeimage(void);
  57. #endif
  58. void NEAR setoffset(void);
  59. void NEAR writenode(LVAL node);
  60. void NEAR writeptr(OFFTYPE off);
  61. void NEAR readnode(int type, LVAL node);
  62. LVAL FAR * NEAR getvspace(LVAL node, unsigned int size);
  63. #else
  64. OFFTYPE readptr();
  65. OFFTYPE cvoptr();
  66. LVAL cviptr();
  67. VOID freeimage();
  68. VOID setoffset();
  69. VOID writenode();
  70. VOID writeptr();
  71. VOID readnode();
  72. LVAL *getvspace();
  73. #endif
  74.  
  75. /* xlisave - save the memory image */
  76. int xlisave(fname)
  77.   char *fname;
  78. {
  79.     char fullname[STRMAX+1];
  80.     SEGMENT FAR *seg;
  81.     int n;
  82.     unsigned i,max;
  83.     LVAL p;
  84.  
  85.     /* default the extension */
  86.     if (needsextension(fname)) {
  87.         strcpy(fullname,fname);
  88.         strcat(fullname,".wks");
  89.         fname = fullname;
  90.     }
  91.  
  92.     /* open the output file */
  93.  
  94.     if ((fp = OSBOPEN(fname,CREATE_WR)) == CLOSED)
  95.         return (FALSE);
  96.  
  97.     /* first call the garbage collector to clean up memory */
  98.     gc();
  99.  
  100.     /* write out size of ftab (used as validity check) TAA MOD */
  101.     writeptr((OFFTYPE)(ftabsize+1));
  102.  
  103.     /* write out the pointer to the *obarray* symbol */
  104.     writeptr(cvoptr(obarray));
  105.  
  106.     /* write out components of NIL other than value, which must be NIL */
  107.     writeptr(cvoptr(getfunction(NIL)));
  108.     writeptr(cvoptr(getplist(NIL)));
  109.     writeptr(cvoptr(getpname(NIL)));
  110.  
  111.     /* setup the initial file offsets */
  112.     off = foff = (OFFTYPE)2;
  113.  
  114.     /* write out all nodes that are still in use */
  115.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  116.         p = &seg->sg_nodes[0];
  117.         for (n = seg->sg_size; --n >= 0; ++p, off++)
  118.             switch (ntype(p)) {
  119.             case FREE:
  120.                 break;
  121.             case CONS:
  122.             case USTREAM:
  123.                 setoffset();
  124.                 OSPUTC(p->n_type,fp);
  125.                 writeptr(cvoptr(car(p)));
  126.                 writeptr(cvoptr(cdr(p)));
  127.                 foff++;
  128.                 break;
  129.             default:
  130.                 setoffset();
  131.                 writenode(p);
  132.                 break;
  133.             }
  134.     }
  135.  
  136.     /* write the terminator */
  137.     OSPUTC(FREE,fp);
  138.     writeptr((OFFTYPE)0);
  139.  
  140.     /* write out data portion of SYMBOL/VECTOR/OBJECT/STRING/CLOSURE nodes */
  141.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  142.         p = &seg->sg_nodes[0];
  143.         for (n = seg->sg_size; --n >= 0; ++p)
  144.             switch (ntype(p)) {
  145.             case SYMBOL:
  146.             case OBJECT:
  147.             case VECTOR:
  148.             case CLOSURE:
  149.             case STRUCT:
  150. #ifdef COMPLX
  151.             case COMPLEX:
  152. #endif
  153.                 max = getsize(p);
  154.                 for (i = 0; i < max; ++i)
  155.                     writeptr(cvoptr(getelement(p,i)));
  156.                 break;
  157.             case STRING:
  158. #ifdef MEDMEM
  159.                 {   /* UGLY, but we gotta do it */
  160.                     char FAR *strp= getstring(p);
  161.                     max = getslength(p)+1;
  162.                     while (max--) OSPUTC(*strp++, fp);
  163.                     break;
  164.                 }
  165. #else
  166.                 max = getslength(p)+1;
  167.                 OSWRITE(getstring(p),1,max,fp);
  168.                 break;
  169. #endif
  170. #ifdef FILETABLE
  171.             case STREAM:
  172.                 if (getfile(p) > CONSOLE ) {
  173.                     OSWRITE(filetab[getfile(p)].tname,1,FNAMEMAX,fp);
  174.                     *(long *)buf = OSTELL(getfile(p));
  175.                     OSWRITE(buf,1,sizeof(long),fp);
  176.                 }
  177.                 break;
  178. #endif
  179.             }
  180.     }
  181.  
  182.     /* close the output file */
  183.     OSCLOSE(fp);
  184.  
  185.     /* return successfully */
  186.     return (TRUE);
  187. }
  188.  
  189. /* xlirestore - restore a saved memory image */
  190. int xlirestore(fname)
  191.   char *fname;
  192. {
  193.     extern FUNDEF funtab[];
  194.     char fullname[STRMAX+1];
  195.     int n,type;
  196.     unsigned i,max;
  197.     SEGMENT FAR *seg;
  198.     LVAL p;
  199.  
  200.     /* default the extension */
  201.     if (needsextension(fname)) {
  202.         strncpy(fullname,fname,STRMAX-4);
  203.         strcat(fullname,".wks");
  204.         fname = fullname;
  205.     }
  206.  
  207.     /* open the file */
  208. #ifdef PATHNAMES
  209.     if ((fp = ospopen(fname,FALSE)) == CLOSED)
  210. #else
  211.     if ((fp = OSBOPEN(fname,OPEN_RO)) == CLOSED)
  212. #endif
  213.         return (FALSE);
  214.  
  215.     /* Check for file validity  TAA MOD */
  216.     if (readptr() != (OFFTYPE) (ftabsize+1)) {
  217.         OSCLOSE(fp);    /* close it -- we failed */
  218.         return (FALSE);
  219.     }
  220.  
  221.     /* free the old memory image */
  222.     freeimage();
  223.  
  224.     /* initialize */
  225.     off = (OFFTYPE)2;
  226.     total = nnodes = nfree = 0L;
  227.     fnodes = NIL;
  228.     segs = lastseg = NULL;
  229.     vsegments = vscurrent = NULL;
  230.     vfree = vtop = NULL;
  231.     vscount = 0;
  232.     nsegs = gccalls = 0;
  233.     xlenv = xlfenv = xldenv = s_gchook = s_gcflag = NIL;
  234.     xlstack = xlstkbase + EDEPTH;
  235.     xlfp = xlsp = xlargstkbase;
  236.     *xlsp++ = NIL;
  237.     xlcontext = NULL;
  238.  
  239.     /* create the fixnum segment */
  240.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  241.         xlfatal("insufficient memory - fixnum segment");
  242.  
  243.     /* create the character segment */
  244.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  245.         xlfatal("insufficient memory - character segment");
  246.  
  247.     /* read the pointer to the *obarray* symbol */
  248.     obarray = cviptr(readptr());
  249.  
  250.     /* read components of NIL other than value, which must be NIL */
  251.     NIL->n_vdata = getvspace(NIL,SYMSIZE);  /* realocate array portion */
  252.     setvalue(NIL, NIL);
  253.     setfunction(NIL, cviptr(readptr()));
  254.     setplist(NIL, cviptr(readptr()));
  255.     setpname(NIL, cviptr(readptr()));
  256.  
  257.  
  258.     /* read each node */
  259.     while ((type = OSGETC(fp)) >= 0)
  260.         switch (type) {
  261.         case FREE:
  262.             if ((off = readptr()) == (OFFTYPE)0)
  263.                 goto done;
  264.             break;
  265.         case CONS:
  266.         case USTREAM:
  267.             p = cviptr(off);
  268.             p->n_type = type;
  269.             rplaca(p,cviptr(readptr()));
  270.             rplacd(p,cviptr(readptr()));
  271.             off++;
  272.             break;
  273.         default:
  274.             readnode(type,cviptr(off));
  275.             off++;
  276.             break;
  277.         }
  278. done:
  279.  
  280.  
  281.     /* read the data portion of SYMBOL/VECTOR/OBJECT/STRING/CLOSURE nodes */
  282.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  283.         p = &seg->sg_nodes[0];
  284.         for (n = seg->sg_size; --n >= 0; ++p)
  285.             switch (ntype(p)) {
  286.             case SYMBOL:
  287.             case OBJECT:
  288.             case VECTOR:
  289.             case CLOSURE:
  290.             case STRUCT:
  291. #ifdef COMPLX
  292.             case COMPLEX:
  293. #endif
  294.                 max = getsize(p);
  295.                 p->n_vdata = getvspace(p,max);
  296.                 for (i = 0; i < max; ++i)
  297.                     setelement(p,i,cviptr(readptr()));
  298.                 break;
  299.             case STRING:
  300. #ifdef MEDMEM
  301.                 {
  302.                     char FAR *chp; int ch;
  303.                     max = getslength(p)+1;
  304.                     p->n_string = (char FAR*)getvspace(p,btow_size(max));
  305.                     chp = getstring(p);
  306.                     while (max--) {
  307.                         if ((ch = OSGETC(fp)) != EOF) *chp++ = ch;
  308.                         else xlfatal("image file corrupted");
  309.                     }
  310.                     break;
  311.                 }
  312. #else
  313.                 max = getslength(p)+1;
  314.                 p->n_string = (char *)getvspace(p,btow_size(max));
  315.                 if (OSREAD(getstring(p),1,max,fp)!=max)
  316.                     xlfatal("image file corrupted");
  317.                 break;
  318. #endif
  319.             case STREAM:
  320. #ifdef FILETABLE
  321.                 if (getfile(p) > CONSOLE) { /* actual file to modify */
  322.                     unsigned long fpos;
  323.                     FILEP f;
  324.  
  325.                     if (OSREAD(buf, 1, FNAMEMAX, fp) != FNAMEMAX ||
  326.                         OSREAD(&fpos, 1, sizeof(long), fp) != sizeof(long))
  327.                         xlfatal("image file corrupted");
  328.                     /* open file in same type, file must exist to succeed */
  329.                     f = ((p->n_sflags & S_BINARY)? OSBOPEN : OSAOPEN)
  330.                         (buf, (p->n_sflags&S_FORWRITING)? OPEN_UPDATE: OPEN_RO);
  331.                     setfile(p, f);
  332.                     if (f != CLOSED) {/* position to same point,
  333.                                         or end if file too short */
  334.                         OSSEEKEND(f);
  335.                         if (OSTELL(f) > fpos) OSSEEK(f, fpos);
  336.                     }
  337.                 }
  338.                 break;
  339. #else
  340.                 setfile(p, CLOSED);
  341.                 break;
  342. #endif
  343.             case SUBR:
  344.             case FSUBR:
  345.                 p->n_subr = funtab[getoffset(p)].fd_subr;
  346.                 break;
  347.             }
  348.     }
  349.  
  350.     if (OSREAD(buf, 1, 1, fp) != 0) /* file too long! */
  351.         xlfatal("image file corrupted--too long");
  352.  
  353.     /* close the input file */
  354.     OSCLOSE(fp);
  355.  
  356.     /* collect to initialize the free space */
  357.     gc();
  358.  
  359.  
  360.     /* lookup all of the symbols the interpreter uses */
  361.     xlsymbols();
  362.  
  363.  
  364.         /* return successfully */
  365.     return (TRUE);
  366. }
  367.  
  368. /* freeimage - free the current memory image */
  369. #ifdef SERVER
  370. VOID freeimage()
  371. #else
  372. LOCAL VOID NEAR freeimage()
  373. #endif
  374. {
  375.     SEGMENT FAR *seg, FAR *next;
  376.     VSEGMENT FAR *vseg, FAR *nextv;
  377.     FILEP fp;
  378.     LVAL p;
  379.     int n;
  380.  
  381.     /* make sure any streams are closed before deleteing segments */
  382.     for (seg = segs; seg != NULL; seg = next) {
  383.         p = &seg->sg_nodes[0];
  384.         for (n = seg->sg_size; --n >= 0; ++p)
  385.             if (ntype(p) == STREAM) {
  386.                 if (((fp = getfile(p)) != CLOSED) &&
  387.                     (fp != STDIN && fp != STDOUT && fp != CONSOLE)) /*TAA Fix*/
  388.                     OSCLOSE(fp);
  389.             }
  390.         next = seg->sg_next;
  391.         MFREE(seg);
  392.     }
  393.  
  394.     for (vseg = vsegments; vseg !=NULL; vseg = nextv) {
  395.         nextv = vseg->vs_next;
  396.         MFREE(vseg);
  397.     }
  398. }
  399.  
  400. /* setoffset - output a positioning command if nodes have been skipped */
  401. LOCAL VOID NEAR setoffset()
  402. {
  403.     if (off != foff) {
  404.         OSPUTC(FREE,fp);
  405.         writeptr(off);
  406.         foff = off;
  407.     }
  408. }
  409.  
  410. /* writenode - write a node to a file */
  411. LOCAL VOID NEAR writenode(node)
  412.   LVAL node;
  413. {
  414. #ifdef MEDMEM
  415.     char buf[sizeof(union ninfo)];
  416.     MEMCPY(buf, &node->n_info, sizeof(union ninfo));
  417. #endif
  418.     OSPUTC(node->n_type,fp);
  419. #ifdef MEDMEM
  420.     OSWRITE(buf, sizeof(union ninfo), 1, fp);
  421. #else
  422.     OSWRITE(&node->n_info, sizeof(union ninfo), 1, fp);
  423. #endif
  424. #ifdef ALIGN32
  425.     if (node->n_type == SYMBOL) OSPUTC(node->n_spflags,fp);
  426. #endif
  427.     foff++;
  428. }
  429.  
  430. /* writeptr - write a pointer to a file */
  431. LOCAL VOID NEAR writeptr(off)
  432.   OFFTYPE off;
  433. {
  434.     OSWRITE(&off, sizeof(OFFTYPE), 1, fp);
  435. }
  436.  
  437. /* readnode - read a node */
  438. LOCAL VOID NEAR readnode(type,node)
  439.   int type; LVAL node;
  440. {
  441. #ifdef MEDMEM
  442.     char buf[sizeof(union ninfo)];
  443. #endif
  444.  
  445.     node->n_type = type;
  446. #ifdef MEDMEM
  447.     if (OSREAD(buf, sizeof(union ninfo), 1, fp) != 1)
  448.         xlfatal("image file corrupted");
  449.     MEMCPY(&node->n_info, buf, sizeof(union ninfo));
  450. #else
  451.     if (OSREAD(&node->n_info, sizeof(union ninfo), 1, fp) != 1)
  452.         xlfatal("image file corrupted");
  453. #endif
  454. #ifdef ALIGN32
  455.     if (type == SYMBOL) node->n_spflags = OSGETC(fp);
  456. #endif
  457. }
  458.  
  459. /* readptr - read a pointer */
  460. LOCAL OFFTYPE NEAR readptr()
  461. {
  462.     OFFTYPE off;
  463.         if (OSREAD(&off, sizeof(OFFTYPE), 1, fp) != 1)
  464.             xlfatal("image file corrupted");
  465.     return (off);
  466. }
  467.  
  468. /* cviptr - convert a pointer on input */
  469. LOCAL LVAL NEAR cviptr(o)
  470.   OFFTYPE o;
  471. {
  472.     OFFTYPE off = (OFFTYPE)2;
  473.     SEGMENT FAR *seg;
  474.  
  475.     /* check for nil */
  476.     if (o == FILENIL)
  477.         return (NIL);
  478.  
  479.     /* compute a pointer for this offset */
  480.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  481.         if (o < off + (OFFTYPE)seg->sg_size)
  482.             return (seg->sg_nodes + (unsigned int)(o - off));
  483.         off += (OFFTYPE)seg->sg_size;
  484.     }
  485.  
  486.     /* create new segments if necessary */
  487.     for (;;) {
  488.  
  489.         /* create the next segment */
  490.         if ((seg = newsegment(anodes)) == NULL)
  491.             xlfatal("insufficient memory - segment");
  492.  
  493.         /* check to see if the offset is in this segment */
  494.         if (o < off + (OFFTYPE)seg->sg_size)
  495.             return (seg->sg_nodes + (unsigned int)(o - off));
  496.         off += (OFFTYPE)seg->sg_size;
  497.     }
  498. }
  499. /* cvoptr - convert a pointer on output */
  500. LOCAL OFFTYPE NEAR cvoptr(p)
  501.   LVAL p;
  502. {
  503.     OFFTYPE off = (OFFTYPE)2;
  504.     SEGMENT FAR *seg;
  505.     OFFTYPE np = CVPTR(p);
  506.  
  507.     /* check for nil */
  508.     if (null(p))
  509.         return (FILENIL);
  510.  
  511.     /* compute an offset for this pointer */
  512.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  513.         if (np >= CVPTR(&seg->sg_nodes[0]) &&
  514.             np <  CVPTR(&seg->sg_nodes[seg->sg_size]))
  515.             return (off+ ((np-CVPTR(seg->sg_nodes))/sizeof(struct node)));
  516.         off += (OFFTYPE)seg->sg_size;
  517.     }
  518.  
  519.     /* pointer not within any segment */
  520.     xlerror("bad pointer found during image save",p);
  521.     return (0); /* fake out compiler warning */
  522. }
  523.  
  524.  
  525. /* getvspace - allocate vector space */
  526. LOCAL LVAL FAR * NEAR getvspace(node,size)
  527.   LVAL node; unsigned int size;
  528. {
  529.     LVAL FAR *p;
  530.     ++size; /* space for the back pointer */
  531.     if ((unsigned)vtop-(unsigned)vfree < size*sizeof(LVAL FAR *) &&
  532.         !scanvmemory(size)) {
  533.         newvsegment(size);
  534.         if ((unsigned)vtop-(unsigned)vfree<size*sizeof(LVAL FAR *))
  535.             xlfatal("insufficient vector space");
  536.     }
  537.     p = vfree;
  538.     vfree += size;
  539.     *p++ = node;
  540.     return (p);
  541. }
  542. #endif
  543.  
  544.